home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / live.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  14.9 KB  |  418 lines
  1. (herald (back_end live)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29.  
  30. (define (analyze top-node)
  31.   (analyze-top top-node)
  32.   (live-analyze-top top-node)
  33.   (collect-top top-node)
  34.   (call-analyze-top top-node)
  35.   (bind ((*noise-flag* t))
  36.     (print-variable-info *unit-variables*))
  37. ;  (type-analyze-top top-node)
  38. ;  (rep-analyze-top top-node)
  39.   (hoist-continuations (lambda-body top-node))
  40.   (close-analyze-top top-node nil))
  41.  
  42. (define (vframe-or-ezclose master)
  43.   (cond ((constant-continuation? master)
  44.          'ezclose)
  45.         (else 'label)))
  46.  
  47. ;;; Live variable analysis
  48.  
  49. (define (live-analyze-top node)
  50.   (live-analyze (car (call-args (lambda-body node)))))
  51.                 
  52.      
  53. (define (live-analyze node)
  54.   (cond ((lambda-node? node)
  55.          (if (labels-master-lambda? node)
  56.              (live-analyze-y node)
  57.              (live-analyze-lambda node)))
  58.         ((leaf-node? node)
  59.          (live-analyze-leaf node))
  60.         (else
  61.          (bug "live-analyze called on a call-node ~S" node))))
  62.                                          
  63. (define (live-analyze-lambda node)
  64.   (receive (live global? known) (live-analyze-body (lambda-body node))
  65.    (let* ((live-1 (set-difference live (lambda-all-variables node)))
  66.            (live (if (neq? (node-role node) call-proc)  ;; Let
  67.                      live-1       
  68.                      (set-difference live-1 (map (lambda (node) 
  69.                                             (and (lambda-node? node)
  70.                                                  (lambda-self-var node)))
  71.                                           (call-args (node-parent node)))))))
  72.     (set (lambda-live node) live)
  73.     (select (lambda-strategy node)
  74.       ((strategy/heap)    
  75.        (walk change-to-heap known)
  76.        (cond ((and (null? live) (not (known-lambda? node)))
  77.               (set (lambda-env node) 'unit-internal-closure)
  78.               (return live t known))
  79.              (global? 
  80.               (set (lambda-env node) 'unit-internal-template)
  81.               (return live t known))
  82.              (else
  83.               (set (lambda-env node) nil)
  84.               (return live nil known))))
  85.       ((strategy/label)                
  86.        (cond ((fully-recursive? node)
  87.           (walk change-to-vframe-or-heap known)
  88.           (cond ((memq? node known))
  89.             ((not (let-lambda? node))
  90.              (change-to-vframe-or-heap node))
  91.             ((fx>= (fx+ (length (lambda-live node)) 
  92.                 (length (lambda-variables node)))
  93.                *argument-registers*)
  94.              (set (lambda-strategy node) strategy/heap)))))
  95.        (set (lambda-env node) (if global? 'needs-link '#f))
  96.        (return live global? known))
  97.       ((strategy/stack)           
  98.        (set (lambda-env node) (if global? 'needs-link '#f))
  99.        (walk (lambda (l)
  100.            (if (fully-recursive? l)
  101.            (change-to-heap l)))
  102.          known)
  103.        (return live global? known))
  104.       (else
  105.        (return live global? known))))))
  106.  
  107.  
  108.  
  109. (define (change-to-vframe-or-heap l)
  110.   (if (and (neq? (lambda-strategy l) strategy/heap)
  111.        (fx>= (fx+ (length (lambda-live l)) (length (lambda-variables l)))
  112.          *argument-registers*))
  113.       (set-label-strategies 
  114.        (node-parent (node-parent l))
  115.        strategy/heap)))
  116.  
  117.  
  118. (define (change-to-heap l) 
  119.   (if (not (fx<= (length (lambda-live l)) 2))
  120.       (set-label-strategies (node-parent (node-parent l))
  121.                             strategy/heap)))
  122.   
  123.  
  124. (define (set-label-strategies node strategy)
  125.   (walk (lambda (l) (set (lambda-strategy l) strategy))
  126.         (cdr (call-args (lambda-body node))))
  127.   (set (lambda-strategy node) strategy))
  128.  
  129.  
  130. (define (live-analyze-leaf node)
  131.   (cond ((literal-node? node)
  132.          (cond ((or (addressable? (leaf-value node))
  133.                     (primop? (leaf-value node)))
  134.                 (return '() nil '()))
  135.                (else
  136.                 (return '() t '()))))
  137.         ((primop-node? node)
  138.          (cond ((foreign-name (primop-value node))
  139.                 (return '() t '()))
  140.                (else 
  141.                 (return '() nil '()))))
  142.         ((variable-known (reference-variable node))
  143.          => (lambda (label)
  144.               (select (lambda-strategy label)
  145.                 ((strategy/label)
  146.                  (return (lambda-live label)
  147.                          (eq? (lambda-env label) 'needs-link)
  148.                          (if (labels-lambda? label) 
  149.                              (list label)  
  150.                              '())))
  151.                 ((strategy/stack)
  152.                  (return '() nil '()))
  153.                 (else 
  154.                  (if (eq? (lambda-env label) 'unit-internal-closure)
  155.                      (return '() t '())
  156.                      (return `(,(lambda-self-var label)) nil '()))))))
  157.         ((bound-to-continuation? (reference-variable node))
  158.          (return '() nil '()))
  159.         ((variable-binder (reference-variable node))
  160.          (return `(,(reference-variable node)) nil '()))
  161.         (else 
  162.          (return '() t '()))))
  163.  
  164. (define (known-lambda? node)
  165.   (let ((p (node-parent (node-parent node))))
  166.     (cond ((node-parent p)
  167.            => (lambda (p)
  168.                 (and (primop-node? (call-proc p))
  169.                      (eq? (primop-value (call-proc p)) primop/Y))))
  170.           (else nil))))
  171.  
  172.  
  173. (define (live-analyze-body node)
  174.   (iterate loop ((args (if (lambda-node? (call-proc node))  
  175.                            (reverse (call-proc+args node))        ; let lambda last!
  176.                            (call-proc+args node)))
  177.                  (live '()) 
  178.                  (global? nil) 
  179.                  (known '()))
  180.     (cond (args
  181.            (receive (vars gl? kn) (live-analyze (car args))
  182.              (loop (cdr args) 
  183.                    (union vars live) 
  184.                    (or global? gl?)
  185.                    (union kn known))))
  186.           ((call-hoisted-cont node)
  187.            => (lambda (l)
  188.                 (return (union live (lambda-live l))
  189.                         (or global? (eq? (lambda-env l) 'needs-link))
  190.                         known)))
  191.           (else
  192.            (return live global? known)))))
  193.                                        
  194.  
  195. (define (live-analyze-Y master)
  196.   (if (and (not (lambda-db master))
  197.            (eq? (lambda-strategy master) strategy/label))
  198.       (set (lambda-db master) (vframe-or-ezclose master)))
  199.   (destructure (((body-expr . label-exprs) (call-args (lambda-body master)))
  200.                 (strategy (lambda-strategy master)))
  201.     (receive (global? known) (set-label-live label-exprs)
  202.       (receive (l gl? kn) (live-analyze-lambda body-expr)
  203.         (if (neq? (lambda-strategy master) strategy)
  204.             (live-analyze-y master)
  205.             (do ((exprs label-exprs (cdr exprs))
  206.                  (live l (union live (lambda-live (car exprs)))))
  207.               ((null? exprs)          
  208.                (return (set-difference (delq! (lambda-self-var master) live)
  209.                                 (map lambda-self-var label-exprs))
  210.                        (or global? gl?)
  211.                        (set-difference (union known kn) label-exprs)))))))))
  212.  
  213.  
  214.  
  215. (define (set-label-live label-exprs)
  216.   (iterate again ()
  217.     (iterate loop ((lambdas label-exprs) 
  218.                    (changed? nil) 
  219.                    (global? nil) 
  220.                    (known '()))
  221.       (cond ((not (null? lambdas))           
  222.              (let ((old-live (lambda-live (car lambdas)))
  223.                    (old-global? (true? (lambda-env (car lambdas)))))
  224.                (receive (live gl? kn) (live-analyze-lambda (car lambdas))
  225.                  (cond ((and (set-eq? old-live live)
  226.                              (eq? gl? old-global?))
  227.                         (loop (cdr lambdas) 
  228.                               changed? 
  229.                               (or global? gl?)
  230.                               (union kn known)))
  231.                        (else
  232.                         (loop (cdr lambdas) 
  233.                               t 
  234.                               (or global? gl?)
  235.                               (union kn known)))))))
  236.             (changed?
  237.              (again))
  238.             (else
  239.              (return global? known))))))
  240.  
  241. (define (hoist-continuation cont)
  242.   (let* ((call (node-parent cont))
  243.          (live (hack-live (lambda-live cont) call)))
  244.   (iterate loop ((call call))
  245.     (let ((l (node-parent call)))       
  246.       (cond ((or (primop-ref? (call-proc (node-parent l))
  247.                   primop/remove-state-object)
  248.              (neq? (lambda-strategy l) strategy/open)
  249.                  (intersection? (lambda-variables l) live)
  250.                  (eq? (node-role l) call-proc)
  251.                  (fxn= (call-exits (node-parent l)) 1))
  252.              (set (call-hoisted-cont call) cont))
  253.             (else
  254.              (loop (node-parent l))))))))
  255.  
  256. (define (hack-live live call)
  257.   (do ((args (cdr (call-args call)) (cdr args))
  258.        (live live (if (and (lambda-node? (car args))
  259.                            (eq? (lambda-strategy (car args)) strategy/hack))
  260.                       (union live (lambda-live (car args)))
  261.                       live)))
  262.     ((null? args) live)))
  263.  
  264.              
  265. (define (collect-top node)
  266.   (set *unit-literals* '())
  267.   (set *unit-variables* '())
  268.   (collect (car (call-args (lambda-body node)))))
  269.  
  270. (define (collect node)
  271.   (cond ((lambda-node? node)
  272.          (walk collect (call-proc+args (lambda-body node))))
  273.         ((literal-node? node)
  274.          (let ((lit (literal-value node)))
  275.            (or (addressable? lit)
  276.                (primop? lit)
  277.                (memq? lit *unit-literals*)
  278.                (push *unit-literals* lit))))
  279.         ((primop-node? node)
  280.          (let ((prim (primop-value node)))
  281.            (and (foreign-name prim)
  282.                 (not (memq? prim *unit-literals*))
  283.                 (push *unit-literals* prim))))
  284.         (else 
  285.          (let ((var (reference-variable node)))
  286.            (or (variable-binder var)
  287.                (memq? var *unit-variables*)
  288.                (push *unit-variables* var))))))
  289.  
  290.  
  291. (define (hoist-continuations node)
  292.   (let ((do-children (lambda (arg)
  293.                (and (lambda-node? arg)
  294.                 (hoist-continuations (lambda-body arg))))))
  295.     (case (call-exits node)
  296.       ((1)
  297.        (destructure (((proc cont . args) (call-proc+args node)))
  298.             (cond ((lambda-node? proc)
  299.                (walk do-children (call-proc+args node))
  300.                nil)
  301.               ((leaf-node? cont) (walk do-children args) nil)
  302.               (else
  303.                (xselect (lambda-strategy cont)
  304.                  ((strategy/open strategy/label)
  305.                   (let ((c (hoist-continuations (lambda-body cont))))
  306.                 (set (call-hoisted-cont node) c)
  307.                 c))
  308.                  ((strategy/stack)
  309.                   (do-children cont)
  310.                   (set (call-hoisted-cont node) cont)))
  311.                (walk do-children args)
  312.                (call-hoisted-cont node)))))
  313.       (else
  314.        (walk do-children (call-proc+args node))
  315.        nil))))
  316.  
  317. (define-constant call-below? node-instructions)
  318. (define-constant call-below/never 0)
  319. (define-constant call-below/maybe 1)
  320. (define-constant call-below/definitely 2)
  321.  
  322.  
  323. (define (call-analyze-top node)
  324.   (call-analyze (lambda-body node)))
  325.  
  326.  
  327.  
  328. (define (call-analyze-leaf node)
  329.   (cond ((lambda-node? node)
  330.      (let ((call-below? (call-analyze (lambda-body node))))
  331.        (select (lambda-strategy node)
  332.          ((strategy/stack) call-below/definitely)
  333.          ((strategy/heap) call-below/never)
  334.          (else call-below?))))
  335.     (else
  336.      call-below/never)))
  337.  
  338. (define (call-analyze node) 
  339.   (let ((below?
  340.        (case (call-exits node)
  341.      ((0)
  342.       (cond ((lambda-node? (call-proc node))
  343.          (call-analyze-let node))
  344.         (else
  345.          (walk call-analyze-leaf (call-args node))
  346.          (call-analyze-known (call-proc node)))))
  347.      ((1)
  348.       (cond ((primop-ref? (call-proc node) primop/y)
  349.          (destructure (((cont master) (call-args node)))
  350.                    (call-analyze-leaf cont)
  351.            (destructure (((body-expr . label-exprs) 
  352.                   (call-args (lambda-body master))))
  353.              (let ((v (call-analyze-leaf body-expr)))
  354.                (cond ((or (and (lambda-node? cont)
  355.                        (eq? (lambda-strategy cont)
  356.                         strategy/stack))
  357.                   (fx= v call-below/definitely))
  358.                   (walk call-analyze-leaf label-exprs)
  359.                   call-below/definitely)
  360.                  (else
  361.                   (do ((l label-exprs (cdr l))
  362.                    (val v (call-below-combine 
  363.                        val
  364.                        (call-analyze-leaf (car l)))))
  365.                   ((null? l) val))))))))
  366.         ((lambda-node? (call-proc node))
  367.          (call-analyze-let node))
  368.         (else
  369.          (destructure (((exit . rest) (call-args node)))
  370.                    (walk call-analyze-leaf rest)
  371.            (cond ((lambda-node? exit)
  372.               (call-analyze-leaf exit))
  373.              (else
  374.               (call-analyze-known (call-proc node))))))))
  375.      ((2)
  376.       (destructure (((th el . rest) (call-args node)))
  377.         (walk call-analyze-leaf rest)
  378.         (call-below-combine (call-analyze-leaf th) (call-analyze-leaf el))))
  379.      (else
  380.       (let ((exits (call-exits node)))
  381.         (do ((below? (call-analyze-leaf ((call-arg 1) node))
  382.              (call-below-combine (call-analyze-leaf ((call-arg i) node))
  383.                          below?))
  384.          (i 2 (fx+ i 1)))
  385.         ((fx> i exits) below?)))))))
  386.     (set (call-below? node) below?)
  387.     below?))
  388.  
  389. (define (call-analyze-let node)
  390.   (iterate loop ((args (call-args node))
  391.          (val call-below/never))
  392.     (cond ((null? args) 
  393.        (let ((body-val (call-analyze-leaf (call-proc node))))
  394.          (cond ((fx= body-val call-below/definitely)
  395.             body-val)
  396.            (else 
  397.             (call-below-combine val body-val)))))
  398.       ((lambda-node? (car args))
  399.        (loop (cdr args)
  400.          (call-below-combine 
  401.           val 
  402.           (call-analyze-leaf (car args)))))
  403.       (else
  404.        (loop (cdr args) val)))))
  405.  
  406. (define (call-analyze-known proc)
  407.     (cond ((and (reference-node? proc)
  408.         (variable-known (reference-variable proc)))
  409.        => (lambda (l) 
  410.         (let ((cb (call-below? (lambda-body l))))
  411.           (if (fixnum? cb) cb call-below/never))))
  412.       (else call-below/never)))
  413.  
  414.  
  415. (let ((vec '#(#(0 1 1) #(1 1 1) #(1 1 2))))
  416.   (define (call-below-combine x y)
  417.     (vref (vref vec x) y)))
  418.